Ici, nous installons les packages nécessaires :
to_be_loaded <- c("tidyverse",
"patchwork",
"glue",
"ggforce",
"plotly",
"ggthemes",
"gapminder",
"ggrepel",
"here",
"ineq",
"DescTools",
"zoo")
for (pck in to_be_loaded) {
if (!require(pck, character.only = TRUE, quietly = TRUE)) {
install.packages(pck, repos="http://cran.rstudio.com/")
suppressPackageStartupMessages(library(pck, character.only = TRUE))
} else {
suppressPackageStartupMessages(library(pck, character.only = TRUE))
}
}
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.1.4 ✔ readr 2.1.5
## ✔ forcats 1.0.0 ✔ stringr 1.5.1
## ✔ ggplot2 3.5.1 ✔ tibble 3.2.1
## ✔ lubridate 1.9.3 ✔ tidyr 1.3.1
## ✔ purrr 1.0.2
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag() masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
##
## Attaching package: 'plotly'
##
##
## The following object is masked from 'package:ggplot2':
##
## last_plot
##
##
## The following object is masked from 'package:stats':
##
## filter
##
##
## The following object is masked from 'package:graphics':
##
## layout
##
##
## here() starts at /Users/evaracine/FAC/B - MIASHS/L3/S6/SCIENCES DES DONNÉES
##
## Registered S3 methods overwritten by 'DescTools':
## method from
## lines.Lc ineq
## plot.Lc ineq
##
##
## Attaching package: 'DescTools'
##
##
## The following objects are masked from 'package:ineq':
##
## Atkinson, Gini, Herfindahl, Lc, Rosenbluth
##
##
##
## Attaching package: 'zoo'
##
##
## The following objects are masked from 'package:base':
##
## as.Date, as.Date.numeric
Nous allons ensuite importer les bases de données Babynames pour les deux pays qui nous intéressent. Puis on les nomme df_us pour les USA, et df_fr pour la France.
if (!require("babynames")){
install.packages("babynames")
stopifnot(require("babynames"), "Couldn't install and load package 'babynames'")
}
## Loading required package: babynames
df_us <- babynames |>
mutate(country='us') |>
mutate(sex=as_factor(sex))
tail(df_us)
## # A tibble: 6 × 6
## year sex name n prop country
## <dbl> <fct> <chr> <int> <dbl> <chr>
## 1 2017 M Zyhier 5 0.00000255 us
## 2 2017 M Zykai 5 0.00000255 us
## 3 2017 M Zykeem 5 0.00000255 us
## 4 2017 M Zylin 5 0.00000255 us
## 5 2017 M Zylis 5 0.00000255 us
## 6 2017 M Zyrie 5 0.00000255 us
path_data <- 'DATA'
fname <- 'nat2021_csv.zip'
fpath <- here(path_data, fname)
if (!file.exists(fpath)){
url <- "https://www.insee.fr/fr/statistiques/fichier/2540004/nat2021_csv.zip"
download.file(url, fpath)
}
df_fr <- readr::read_csv2(fpath)
## ℹ Using "','" as decimal and "'.'" as grouping mark. Use `read_delim()` for more control.
## Rows: 686538 Columns: 4
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ";"
## chr (2): preusuel, annais
## dbl (2): sexe, nombre
##
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
df_fr |> glimpse()
## Rows: 686,538
## Columns: 4
## $ sexe <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1…
## $ preusuel <chr> "_PRENOMS_RARES", "_PRENOMS_RARES", "_PRENOMS_RARES", "_PRENO…
## $ annais <chr> "1900", "1901", "1902", "1903", "1904", "1905", "1906", "1907…
## $ nombre <dbl> 1249, 1342, 1330, 1286, 1430, 1472, 1451, 1514, 1509, 1526, 1…
lkp <- list(year="annais",
sex="sexe",
name="preusuel",
n="nombre")
df_fr <- df_fr |>
rename(!!!lkp) |>
mutate(country='fr') |>
mutate(sex=as_factor(sex)) |>
mutate(sex=fct_recode(sex, "M"="1", "F"="2")) |>
mutate(sex=fct_relevel(sex, "F", "M")) |>
mutate(year=ifelse(year=="XXXX", NA, year)) |>
mutate(year=as.integer(year)) |>
arrange(year)
df_fr
## # A tibble: 686,538 × 5
## sex name year n country
## <fct> <chr> <int> <dbl> <chr>
## 1 M _PRENOMS_RARES 1900 1249 fr
## 2 M ABDON 1900 4 fr
## 3 M ABEL 1900 428 fr
## 4 M ABRAHAM 1900 19 fr
## 5 M ACHILLE 1900 205 fr
## 6 M ACHILLES 1900 6 fr
## 7 M ADALBERT 1900 7 fr
## 8 M ADAM 1900 20 fr
## 9 M ADELIN 1900 7 fr
## 10 M ADHEMAR 1900 5 fr
## # ℹ 686,528 more rows
La base de donnée des USA n’est pas tout à fait la même que celle de la France. On va donc drop les années de 1880 à 1899 et la colonne “prop” de df_us et les années de 2018 à 2021 de df_fr. Ainsi, les deux tables auront exactement les mêmes années et colonnes.
df_us <- df_us |> select(-prop) |> subset(year>=1900)
df_fr <- df_fr |> subset(year<=2017)
df_us
## # A tibble: 1,872,400 × 5
## year sex name n country
## <dbl> <fct> <chr> <int> <chr>
## 1 1900 F Mary 16706 us
## 2 1900 F Helen 6343 us
## 3 1900 F Anna 6114 us
## 4 1900 F Margaret 5304 us
## 5 1900 F Ruth 4765 us
## 6 1900 F Elizabeth 4096 us
## 7 1900 F Florence 3920 us
## 8 1900 F Ethel 3896 us
## 9 1900 F Marie 3856 us
## 10 1900 F Lillian 3414 us
## # ℹ 1,872,390 more rows
df_fr
## # A tibble: 593,606 × 5
## sex name year n country
## <fct> <chr> <int> <dbl> <chr>
## 1 M _PRENOMS_RARES 1900 1249 fr
## 2 M ABDON 1900 4 fr
## 3 M ABEL 1900 428 fr
## 4 M ABRAHAM 1900 19 fr
## 5 M ACHILLE 1900 205 fr
## 6 M ACHILLES 1900 6 fr
## 7 M ADALBERT 1900 7 fr
## 8 M ADAM 1900 20 fr
## 9 M ADELIN 1900 7 fr
## 10 M ADHEMAR 1900 5 fr
## # ℹ 593,596 more rows
Calculer pour chaque année, sexe et pays les indicateurs suivants de la dispersion/concentration de la distribution des prénoms.
make_lorenz_df <- function(df) {
df |>
group_by(year, sex) |>
arrange(n) |>
mutate(rr=row_number()/n(), L=cumsum(n)/sum(n), p=n/sum(n)) |>
ungroup()
}
#Pour la France :
df_lorenz_fr <- df_fr |>
filter(name != '_PRENOMS_RARES' & !is.na(year)) |>
make_lorenz_df()
df_lorenz_fr
## # A tibble: 593,369 × 8
## sex name year n country rr L p
## <fct> <chr> <int> <dbl> <chr> <dbl> <dbl> <dbl>
## 1 M AGNAN 1900 3 fr 0.00138 0.0000170 0.0000170
## 2 M ALFREDE 1900 3 fr 0.00277 0.0000341 0.0000170
## 3 M ALLYRE 1900 3 fr 0.00415 0.0000511 0.0000170
## 4 M ALMIR 1900 3 fr 0.00553 0.0000681 0.0000170
## 5 M ALPHEE 1900 3 fr 0.00692 0.0000852 0.0000170
## 6 M AMÉLIE 1900 3 fr 0.00830 0.000102 0.0000170
## 7 M ANASTHASE 1900 3 fr 0.00968 0.000119 0.0000170
## 8 M ANGE-MARIE 1900 3 fr 0.0111 0.000136 0.0000170
## 9 M ANGELBERT 1900 3 fr 0.0124 0.000153 0.0000170
## 10 M ANNIBAL 1900 3 fr 0.0138 0.000170 0.0000170
## # ℹ 593,359 more rows
#Pour les US :
df_lorenz_us <- df_us |>
make_lorenz_df()
df_lorenz_us
## # A tibble: 1,872,400 × 8
## year sex name n country rr L p
## <dbl> <fct> <chr> <int> <chr> <dbl> <dbl> <dbl>
## 1 1900 F Adabelle 5 us 0.000450 0.0000167 0.0000167
## 2 1900 F Afton 5 us 0.000899 0.0000334 0.0000167
## 3 1900 F Ailene 5 us 0.00135 0.0000500 0.0000167
## 4 1900 F Alfhild 5 us 0.00180 0.0000667 0.0000167
## 5 1900 F Algie 5 us 0.00225 0.0000834 0.0000167
## 6 1900 F Alleine 5 us 0.00270 0.000100 0.0000167
## 7 1900 F Almeter 5 us 0.00315 0.000117 0.0000167
## 8 1900 F Alzada 5 us 0.00360 0.000133 0.0000167
## 9 1900 F Alzina 5 us 0.00405 0.000150 0.0000167
## 10 1900 F Amada 5 us 0.00450 0.000167 0.0000167
## # ℹ 1,872,390 more rows
row_number : rang/classement des prénoms par année et par sexe du plus au moins donné. C’est l’indice i dans lz formule mathématique de la courbe de Lorenz. (rang 1= prénom de moins donné dans l’année).
n() : calcule le nombre de prénoms donnés dans l’année par sexe.
sum(n) : nombre total de naissance par année et par sexe.
rr : le rang divisé par le nombre total de prénom par année et par sexe. Indice de rareté par année. Plus c’est grand(proche de 1) moins c’est rare. Plus c’est proche de 0, plus c’est rare.
cumsum(n) : somme cumulée du nombre de naissances.
p : la fréquence du prénom par année et par sexe.
#Indice de Gini France :
p_gini_fr <- df_lorenz_fr |>
group_by (year,sex) |>
summarize(Gini=2*sum(rr*p)-1-1/n(), .groups='drop') |>
mutate (country = 'FRANCE')
p_gini_fr
## # A tibble: 236 × 4
## year sex Gini country
## <int> <fct> <dbl> <chr>
## 1 1900 F 0.912 FRANCE
## 2 1900 M 0.902 FRANCE
## 3 1901 F 0.913 FRANCE
## 4 1901 M 0.902 FRANCE
## 5 1902 F 0.914 FRANCE
## 6 1902 M 0.903 FRANCE
## 7 1903 F 0.913 FRANCE
## 8 1903 M 0.906 FRANCE
## 9 1904 F 0.913 FRANCE
## 10 1904 M 0.908 FRANCE
## # ℹ 226 more rows
#Indice de Gini USA :
p_gini_us <- df_lorenz_us |>
group_by (year,sex) |>
summarize(Gini=2*sum(rr*p)-1-1/n(), .groups='drop')|>
mutate (country = 'USA')
p_gini_us
## # A tibble: 236 × 4
## year sex Gini country
## <dbl> <fct> <dbl> <chr>
## 1 1900 F 0.863 USA
## 2 1900 M 0.847 USA
## 3 1901 F 0.852 USA
## 4 1901 M 0.828 USA
## 5 1902 F 0.855 USA
## 6 1902 M 0.836 USA
## 7 1903 F 0.856 USA
## 8 1903 M 0.833 USA
## 9 1904 F 0.858 USA
## 10 1904 M 0.837 USA
## # ℹ 226 more rows
#On joint les deux tables :
gini <- full_join(p_gini_fr,p_gini_us, by = c('sex', 'year', 'country', 'Gini'))
gini
## # A tibble: 472 × 4
## year sex Gini country
## <dbl> <fct> <dbl> <chr>
## 1 1900 F 0.912 FRANCE
## 2 1900 M 0.902 FRANCE
## 3 1901 F 0.913 FRANCE
## 4 1901 M 0.902 FRANCE
## 5 1902 F 0.914 FRANCE
## 6 1902 M 0.903 FRANCE
## 7 1903 F 0.913 FRANCE
## 8 1903 M 0.906 FRANCE
## 9 1904 F 0.913 FRANCE
## 10 1904 M 0.908 FRANCE
## # ℹ 462 more rows
#Entropie de Shannon, fonction :
p_shannon <- function(df, co) {
df |>
group_by(year, sex) |>
mutate(p=n/sum(n)) |>
summarize(Shannon=sum(p*log(p, base = 2)), .groups='drop') |>
mutate (country = co )
}
#Entropie de Shannon pour la France :
p_shannon_fr <- p_shannon(df_fr, 'FRANCE')
p_shannon_fr
## # A tibble: 236 × 4
## year sex Shannon country
## <int> <fct> <dbl> <chr>
## 1 1900 F -6.21 FRANCE
## 2 1900 M -6.32 FRANCE
## 3 1901 F -6.23 FRANCE
## 4 1901 M -6.30 FRANCE
## 5 1902 F -6.25 FRANCE
## 6 1902 M -6.29 FRANCE
## 7 1903 F -6.28 FRANCE
## 8 1903 M -6.28 FRANCE
## 9 1904 F -6.28 FRANCE
## 10 1904 M -6.29 FRANCE
## # ℹ 226 more rows
#Entropie de Shannon pour les US, sans la fonction :
p_shannon_us <- p_shannon(df_us, "USA")
p_shannon_us
## # A tibble: 236 × 4
## year sex Shannon country
## <dbl> <fct> <dbl> <chr>
## 1 1900 F -8.22 USA
## 2 1900 M -7.55 USA
## 3 1901 F -8.19 USA
## 4 1901 M -7.50 USA
## 5 1902 F -8.20 USA
## 6 1902 M -7.54 USA
## 7 1903 F -8.21 USA
## 8 1903 M -7.56 USA
## 9 1904 F -8.23 USA
## 10 1904 M -7.61 USA
## # ℹ 226 more rows
#On joint les deux tables :
shannon <- full_join(p_shannon_fr, p_shannon_us, by = c('country','sex', 'year','Shannon'))
shannon
## # A tibble: 472 × 4
## year sex Shannon country
## <dbl> <fct> <dbl> <chr>
## 1 1900 F -6.21 FRANCE
## 2 1900 M -6.32 FRANCE
## 3 1901 F -6.23 FRANCE
## 4 1901 M -6.30 FRANCE
## 5 1902 F -6.25 FRANCE
## 6 1902 M -6.29 FRANCE
## 7 1903 F -6.28 FRANCE
## 8 1903 M -6.28 FRANCE
## 9 1904 F -6.28 FRANCE
## 10 1904 M -6.29 FRANCE
## # ℹ 462 more rows
Nous vérifions rapidement si les données trouvées sont bonnes grâce à la fonction Entropy du package ineq, en utilisant, par exemple, l’année 1900 et le sexe M pour la France :
shannon_fr_test <- df_lorenz_fr |> filter(year==1900 & sex=='M')
Entropy(shannon_fr_test$p, base=2)
## [1] 6.301048
#Entropie de Rényi, fonction :
p_renyi <- function(df, co){
df |>
group_by(year,sex) |>
arrange(n) |>
mutate(p=n/sum(n)) |>
summarize(Renyi=-log(sum(p**2),base = 2), .groups='drop') |>
mutate (country = co )
}
#Pour la France :
p_renyi_fr <- p_renyi(df_fr, 'FRANCE')
p_renyi_fr
## # A tibble: 236 × 4
## year sex Renyi country
## <int> <fct> <dbl> <chr>
## 1 1900 F 4.23 FRANCE
## 2 1900 M 5.34 FRANCE
## 3 1901 F 4.25 FRANCE
## 4 1901 M 5.32 FRANCE
## 5 1902 F 4.30 FRANCE
## 6 1902 M 5.31 FRANCE
## 7 1903 F 4.36 FRANCE
## 8 1903 M 5.31 FRANCE
## 9 1904 F 4.39 FRANCE
## 10 1904 M 5.31 FRANCE
## # ℹ 226 more rows
#Pour les US :
p_renyi_us <- p_renyi(df_us, 'USA')
p_renyi_us
## # A tibble: 236 × 4
## year sex Renyi country
## <dbl> <fct> <dbl> <chr>
## 1 1900 F 6.83 USA
## 2 1900 M 5.86 USA
## 3 1901 F 6.83 USA
## 4 1901 M 5.90 USA
## 5 1902 F 6.83 USA
## 6 1902 M 5.92 USA
## 7 1903 F 6.83 USA
## 8 1903 M 5.94 USA
## 9 1904 F 6.83 USA
## 10 1904 M 5.98 USA
## # ℹ 226 more rows
#On joint les deux tables :
renyi <- full_join(p_renyi_fr, p_renyi_us, by = c('country','sex', 'year','Renyi'))
renyi
## # A tibble: 472 × 4
## year sex Renyi country
## <dbl> <fct> <dbl> <chr>
## 1 1900 F 4.23 FRANCE
## 2 1900 M 5.34 FRANCE
## 3 1901 F 4.25 FRANCE
## 4 1901 M 5.32 FRANCE
## 5 1902 F 4.30 FRANCE
## 6 1902 M 5.31 FRANCE
## 7 1903 F 4.36 FRANCE
## 8 1903 M 5.31 FRANCE
## 9 1904 F 4.39 FRANCE
## 10 1904 M 5.31 FRANCE
## # ℹ 462 more rows
#Fonction :
p_alker <- function(lorenz, co){
lorenz |> arrange(year,sex) |> filter(L>0.5) |>
group_by(year,sex) |>
summarize(Alker=min(rr), .groups='drop')|>
mutate (country = co )
}
#Pour la France :
p_alker_fr <- p_alker(df_lorenz_fr, 'FRANCE')
p_alker_fr
## # A tibble: 236 × 4
## year sex Alker country
## <int> <fct> <dbl> <chr>
## 1 1900 F 0.987 FRANCE
## 2 1900 M 0.982 FRANCE
## 3 1901 F 0.987 FRANCE
## 4 1901 M 0.982 FRANCE
## 5 1902 F 0.987 FRANCE
## 6 1902 M 0.982 FRANCE
## 7 1903 F 0.987 FRANCE
## 8 1903 M 0.982 FRANCE
## 9 1904 F 0.987 FRANCE
## 10 1904 M 0.983 FRANCE
## # ℹ 226 more rows
#Pour les USA :
p_alker_us <- p_alker(df_lorenz_us, 'USA')
p_alker_us
## # A tibble: 236 × 4
## year sex Alker country
## <dbl> <fct> <dbl> <chr>
## 1 1900 F 0.978 USA
## 2 1900 M 0.984 USA
## 3 1901 F 0.975 USA
## 4 1901 M 0.980 USA
## 5 1902 F 0.976 USA
## 6 1902 M 0.981 USA
## 7 1903 F 0.977 USA
## 8 1903 M 0.980 USA
## 9 1904 F 0.977 USA
## 10 1904 M 0.981 USA
## # ℹ 226 more rows
#On joint les deux tables :
alker <- full_join(p_alker_fr, p_alker_us, by = c('country','sex', 'year','Alker'))
alker
## # A tibble: 472 × 4
## year sex Alker country
## <dbl> <fct> <dbl> <chr>
## 1 1900 F 0.987 FRANCE
## 2 1900 M 0.982 FRANCE
## 3 1901 F 0.987 FRANCE
## 4 1901 M 0.982 FRANCE
## 5 1902 F 0.987 FRANCE
## 6 1902 M 0.982 FRANCE
## 7 1903 F 0.987 FRANCE
## 8 1903 M 0.982 FRANCE
## 9 1904 F 0.987 FRANCE
## 10 1904 M 0.983 FRANCE
## # ℹ 462 more rows
a=0.1
#Fonction
p_decile <- function(lorenz, co) {
lorenz |> arrange(year,sex) |> filter(rr>=1-a) |>
group_by(year, sex) |>
summarize(Decile=1-min(L), .groups = 'drop') |>
arrange(year)|>
mutate (country = co )
}
#Pour la France :
p_decile_fr <- p_decile(df_lorenz_fr, 'FRANCE')
p_decile_fr
## # A tibble: 236 × 4
## year sex Decile country
## <int> <fct> <dbl> <chr>
## 1 1900 F 0.891 FRANCE
## 2 1900 M 0.877 FRANCE
## 3 1901 F 0.893 FRANCE
## 4 1901 M 0.876 FRANCE
## 5 1902 F 0.894 FRANCE
## 6 1902 M 0.879 FRANCE
## 7 1903 F 0.895 FRANCE
## 8 1903 M 0.883 FRANCE
## 9 1904 F 0.894 FRANCE
## 10 1904 M 0.887 FRANCE
## # ℹ 226 more rows
#Pour les US :
p_decile_us <- p_decile(df_lorenz_us, 'USA')
p_decile_us
## # A tibble: 236 × 4
## year sex Decile country
## <dbl> <fct> <dbl> <chr>
## 1 1900 F 0.834 USA
## 2 1900 M 0.808 USA
## 3 1901 F 0.815 USA
## 4 1901 M 0.781 USA
## 5 1902 F 0.822 USA
## 6 1902 M 0.792 USA
## 7 1903 F 0.823 USA
## 8 1903 M 0.787 USA
## 9 1904 F 0.826 USA
## 10 1904 M 0.794 USA
## # ℹ 226 more rows
#On joint les deux tables :
decile <- full_join(p_decile_fr, p_decile_us, by = c('country','sex', 'year','Decile'))
decile
## # A tibble: 472 × 4
## year sex Decile country
## <dbl> <fct> <dbl> <chr>
## 1 1900 F 0.891 FRANCE
## 2 1900 M 0.877 FRANCE
## 3 1901 F 0.893 FRANCE
## 4 1901 M 0.876 FRANCE
## 5 1902 F 0.894 FRANCE
## 6 1902 M 0.879 FRANCE
## 7 1903 F 0.895 FRANCE
## 8 1903 M 0.883 FRANCE
## 9 1904 F 0.894 FRANCE
## 10 1904 M 0.887 FRANCE
## # ℹ 462 more rows
#Indice d'Atkinson, fonction :
a=0.5
p_atkinson <- function(df, co){
df |>
group_by(year,sex) |>
mutate(p=n/sum(n)) |>
summarize(Atkinson = 1 - (1/n()) * (sum(p**(1-a)))**(1/(1-a)), .groups = 'drop')|>
mutate (country = co )
}
#Pour la France :
p_atkin_fr <- p_atkinson(df_fr, 'FRANCE')
p_atkin_fr
## # A tibble: 236 × 4
## year sex Atkinson country
## <int> <fct> <dbl> <chr>
## 1 1900 F 0.756 FRANCE
## 2 1900 M 0.732 FRANCE
## 3 1901 F 0.758 FRANCE
## 4 1901 M 0.733 FRANCE
## 5 1902 F 0.760 FRANCE
## 6 1902 M 0.735 FRANCE
## 7 1903 F 0.759 FRANCE
## 8 1903 M 0.743 FRANCE
## 9 1904 F 0.759 FRANCE
## 10 1904 M 0.746 FRANCE
## # ℹ 226 more rows
#Pour les US :
p_atkin_us <- p_atkinson(df_us, 'USA')
p_atkin_us
## # A tibble: 236 × 4
## year sex Atkinson country
## <dbl> <fct> <dbl> <chr>
## 1 1900 F 0.654 USA
## 2 1900 M 0.632 USA
## 3 1901 F 0.634 USA
## 4 1901 M 0.599 USA
## 5 1902 F 0.641 USA
## 6 1902 M 0.611 USA
## 7 1903 F 0.643 USA
## 8 1903 M 0.606 USA
## 9 1904 F 0.646 USA
## 10 1904 M 0.613 USA
## # ℹ 226 more rows
#On joint les deux tables :
atkinson <- full_join(p_atkin_fr, p_atkin_us, by = c('country','sex', 'year','Atkinson'))
atkinson
## # A tibble: 472 × 4
## year sex Atkinson country
## <dbl> <fct> <dbl> <chr>
## 1 1900 F 0.756 FRANCE
## 2 1900 M 0.732 FRANCE
## 3 1901 F 0.758 FRANCE
## 4 1901 M 0.733 FRANCE
## 5 1902 F 0.760 FRANCE
## 6 1902 M 0.735 FRANCE
## 7 1903 F 0.759 FRANCE
## 8 1903 M 0.743 FRANCE
## 9 1904 F 0.759 FRANCE
## 10 1904 M 0.746 FRANCE
## # ℹ 462 more rows
On vérifie rapidement si les données trouvées sont bonnes grâce à la fonction Atkinson du package ineq. Ici, on a fixé le paramètre alpha à 0.5 comme au dessus. :
atkinson_fr_test <- df_lorenz_fr |> filter(year==1900 & sex=='M')
Atkinson(atkinson_fr_test$p, parameter = 0.5, na.rm = TRUE)
## [1] 0.7328435
A <- merge(gini, shannon, by = c('country','sex', 'year'))
B <- merge(A, renyi, by = c('country','sex', 'year'))
C <- merge(B, alker, by = c('country','sex', 'year'))
D <- merge(C, decile, by = c('country','sex', 'year'))
E <- merge(D, atkinson, by = c('country','sex', 'year'))
indicateurs <- E |> arrange (year)
head(indicateurs)
## country sex year Gini Shannon Renyi Alker Decile Atkinson
## 1 FRANCE F 1900 0.9116964 -6.212928 4.225040 0.9867752 0.8908853 0.7559698
## 2 FRANCE M 1900 0.9016836 -6.317148 5.336395 0.9820194 0.8765911 0.7318710
## 3 USA F 1900 0.8625660 -8.220351 6.828812 0.9784173 0.8339693 0.6542068
## 4 USA M 1900 0.8469594 -7.547574 5.856137 0.9840637 0.8075862 0.6320653
## 5 FRANCE F 1901 0.9126356 -6.233539 4.251018 0.9871287 0.8933395 0.7577341
## 6 FRANCE M 1901 0.9022316 -6.301738 5.323439 0.9819193 0.8760572 0.7330794
Tracer les graphes de l’évolution de ces indicateurs de la dispersion/concentration de la distribution. Utiliser le mécanisme des facettes pour juxtaposer les graphes correspondants aux quatre couples (Pays, Sexe). Pour chaque (Pays, Sexe), superposez les graphes des indicateurs en fonction du temps.
g_gini <- ggplot(gini) +
aes(x=year, y=Gini, group=sex)+
geom_line(aes(color=sex))
g_gini+facet_grid(sex~country) +
labs(title="Évolution de l'Indice de Gini par pays et par sexe")+
xlab("années") +
ylab("indice de Gini") +
theme(plot.title = element_text(size=12, face="bold", hjust = 0.5),
legend.position = "bottom" ,
axis.title.x = element_text(size=8, face="bold", hjust = 0.5),
axis.title.y = element_text(size=8, face="bold", hjust = 0.5))
g_shannon<- ggplot(shannon) +
aes(x=year, y=Shannon, group=sex)+
geom_line(aes(color=sex))
g_shannon+facet_grid(sex~country) +
labs(title="Évolution de l'Entropie de Shannon par pays et par sexe")+
xlab("années") +
ylab("entropie de Shannon") +
theme(plot.title = element_text(size=12, face="bold", hjust = 0.5),
legend.position = "bottom" ,
axis.title.x = element_text(size=8, face="bold", hjust = 0.5),
axis.title.y = element_text(size=8, face="bold", hjust = 0.5))
g_renyi <- ggplot(renyi) +
aes(x=year, y=Renyi, group=sex)+
geom_line(aes(color=sex))
g_renyi+facet_grid(sex~country) +
labs(title="Évolution de l'Entropie de Renyi par pays et par sexe")+
xlab("années") +
ylab("entropie de Renyi") +
theme(plot.title = element_text(size=12, face="bold", hjust = 0.5),
legend.position = "bottom" ,
axis.title.x = element_text(size=8, face="bold", hjust = 0.5),
axis.title.y = element_text(size=8, face="bold", hjust = 0.5))
g_alker <- ggplot(alker) +
aes(x=year, y=Alker, group=sex)+
geom_line(aes(color=sex))
g_alker+facet_grid(sex~country) +
labs(title="Évolution de la majorité minimale d'Alker par pays et par sexe")+
xlab("années") +
ylab("majorité minimale d'Alker") +
theme(plot.title = element_text(size=12, face="bold", hjust = 0.5),
legend.position = "bottom" ,
axis.title.x = element_text(size=8, face="bold", hjust = 0.5),
axis.title.y = element_text(size=8, face="bold", hjust = 0.5))
g_decile <- ggplot(decile) +
aes(x=year, y=Decile, group=sex)+
geom_line(aes(color=sex))
g_decile+facet_grid(sex~country) +
labs(title="Évolution de la part du dernier décile par pays et par sexe")+
xlab("années") +
ylab("part du dernier décile") +
theme(plot.title = element_text(size=12, face="bold", hjust = 0.5),
legend.position = "bottom" ,
axis.title.x = element_text(size=8, face="bold", hjust = 0.5),
axis.title.y = element_text(size=8, face="bold", hjust = 0.5))
g_atkinson <- ggplot(atkinson) +
aes(x=year, y=Atkinson, group=sex)+
geom_line(aes(color=sex))
g_atkinson+facet_grid(sex~country) +
labs(title="Évolution de l'Indice d'Atkinson par pays et par sexe")+
xlab("années") +
ylab("indice d'Atkinson") +
theme(plot.title = element_text(size=12, face="bold", hjust = 0.5),
legend.position = "bottom" ,
axis.title.x = element_text(size=8, face="bold", hjust = 0.5),
axis.title.y = element_text(size=8, face="bold", hjust = 0.5))
indicateurs_long <- indicateurs |>
pivot_longer(cols = c(-country, -sex, -year), names_to = "indicateur", values_to = "valeur")
indicateurs_long
## # A tibble: 2,832 × 5
## country sex year indicateur valeur
## <chr> <fct> <dbl> <chr> <dbl>
## 1 FRANCE F 1900 Gini 0.912
## 2 FRANCE F 1900 Shannon -6.21
## 3 FRANCE F 1900 Renyi 4.23
## 4 FRANCE F 1900 Alker 0.987
## 5 FRANCE F 1900 Decile 0.891
## 6 FRANCE F 1900 Atkinson 0.756
## 7 FRANCE M 1900 Gini 0.902
## 8 FRANCE M 1900 Shannon -6.32
## 9 FRANCE M 1900 Renyi 5.34
## 10 FRANCE M 1900 Alker 0.982
## # ℹ 2,822 more rows
g_indicateurs <- ggplot(indicateurs_long) +
aes(x = year, y = valeur, group = indicateur, color = indicateur) +
geom_line(aes(color=indicateur))+
scale_y_continuous(sec.axis = sec_axis(~ . -10))+
facet_grid(sex ~ country, scales = "free") +
labs(title = "Évolution des Indicateurs par pays et par sexe",
x = "Année",
y = "Valeur",
color = "Indicateurs",
subtitle = "Comparaison des indicateurs") +
theme(plot.title = element_text(size = 12, face = "bold", hjust = 0.5),
legend.position = "bottom",
axis.title.x = element_text(size = 8, face = "bold", hjust = 0.5),
axis.title.y = element_text(size = 8, face = "bold", hjust = 0.5))
graphe<- ggplotly(g_indicateurs, dynamicTicks = TRUE)
config(graphe, scrollZoom=TRUE)
Avec la fonction ggplotly (du package plotly), on crée un graphique interactif qui nous permet de zoomer. En effet, Shannon et Renyi ne sont pas à la même échelle, ce qui fait qu’on ne distingue pas toutes les autres courbes. Avec ggplotly et en plaçant notre curseur sur l’axe des valeurs, on peut zoomer à plus petite échelle et ainsi les courbes de Alker, Atkinson, Gini et de la part du dernier décile se distinguent.
name_fr_select <- df_fr |> filter(year %in% c(1950,1990,2015))
name_us_select <- df_us |> filter(year %in% c(1950,1990,2015))
popularite_desc <- function(df){
df|>
group_by(year,sex) |>
arrange(desc(n)) |>
mutate(rr=row_number(), p=n/sum(n))
}
pop_fr <- popularite_desc(name_fr_select)
pop_fr
## # A tibble: 24,032 × 7
## # Groups: year, sex [6]
## sex name year n country rr p
## <fct> <chr> <int> <dbl> <chr> <int> <dbl>
## 1 M JEAN 1950 38306 fr 1 0.0846
## 2 F MARIE 1950 28061 fr 1 0.0650
## 3 M MICHEL 1950 27956 fr 2 0.0617
## 4 F _PRENOMS_RARES 2015 26827 fr 1 0.0702
## 5 M _PRENOMS_RARES 2015 24925 fr 1 0.0620
## 6 M ALAIN 1950 24047 fr 3 0.0531
## 7 M GÉRARD 1950 18617 fr 4 0.0411
## 8 M BERNARD 1950 18355 fr 5 0.0405
## 9 M DANIEL 1950 18225 fr 6 0.0402
## 10 M CHRISTIAN 1950 17040 fr 7 0.0376
## # ℹ 24,022 more rows
pop_us <- popularite_desc(name_us_select)
pop_us
## # A tibble: 68,119 × 7
## # Groups: year, sex [6]
## year sex name n country rr p
## <dbl> <fct> <chr> <int> <chr> <int> <dbl>
## 1 1950 M James 86239 us 1 0.0482
## 2 1950 M Robert 83565 us 2 0.0467
## 3 1950 F Linda 80432 us 1 0.0469
## 4 1950 M John 79420 us 3 0.0444
## 5 1950 F Mary 65482 us 2 0.0382
## 6 1990 M Michael 65282 us 1 0.0318
## 7 1950 M Michael 65151 us 4 0.0364
## 8 1950 M David 60730 us 5 0.0339
## 9 1950 M William 60690 us 6 0.0339
## 10 1990 M Christopher 52332 us 2 0.0255
## # ℹ 68,109 more rows
#Pour la France :
zipf_France <- ggplot(pop_fr) +
aes(x = log(rr), y = log(p), group = year, color = as.factor(year)) +
geom_point()+
facet_grid(sex~., scales = "free") +
labs(title = "Diagramme de Zipf pour la France \npour les années 1950,1990,2015",
x = "Rang du prénom à l'échelle logarithmique",
y = "Popularité du prénom à l'échelle logarithmique",
color = "Années") +
theme(plot.title = element_text(size = 12, face = "bold", hjust = 0.5),
legend.position = "bottom")
zipf_USA <- ggplot(pop_us) +
aes(x = log(rr), y = log(p), group = year, color = as.factor(year)) +
geom_point()+
facet_grid(sex~., scales = "free") +
labs(title = "Diagramme de Zipf pour les USA \npour les années 1950,1990,2015",
x = "Rang du prénom à l'échelle logarithmique",
y = "Popularité du prénom à l'échelle logarithmique",
color = "Années") +
theme(plot.title = element_text(size = 12, face = "bold", hjust = 0.5),
legend.position = "bottom")
zipf_France + zipf_USA
On commence par filtrer la base de données et en créée une nouvelle avec les années qui nous intéressent, c’est-à-dire les années depuis 1948.
#Pour la France :
name_fr_48 <- df_fr |> filter(name != '_PRENOMS_RARES' & !is.na(year) & year >=1948)
#Pour les US :
name_us_48 <- df_us |> filter(name != '_PRENOMS_RARES' & !is.na(year) & year >=1948)
Ensuite, on va selectionner les prénoms qui ont figurés au moins une fois parmi les 300 prénoms les plus populaires depuis 1948 pour les deux pays :
#Pour la France :
name_fr_300 <- name_fr_48 |>
group_by(year,sex) |>
arrange(desc(n)) |> #car pour le n est grand, plus le prénom a été donné. Donc on veut les ranger par ordre décroissant afin de les numéroter du plus donné au moins donné.
mutate(rr=row_number(),p=n/sum(n)) |> #rr est le rang et p la popularité. On aura besoin de p pour faire la moyenne mobile.
filter(rr<=300) |>
arrange(name,year,sex)
name_fr_300
## # A tibble: 42,000 × 7
## # Groups: year, sex [140]
## sex name year n country rr p
## <fct> <chr> <int> <dbl> <chr> <int> <dbl>
## 1 M AARON 2004 335 fr 206 0.000865
## 2 M AARON 2005 439 fr 168 0.00113
## 3 M AARON 2006 598 fr 120 0.00150
## 4 M AARON 2007 910 fr 83 0.00231
## 5 M AARON 2008 1380 fr 59 0.00346
## 6 M AARON 2009 1355 fr 56 0.00343
## 7 M AARON 2010 1606 fr 50 0.00403
## 8 M AARON 2011 1765 fr 43 0.00450
## 9 M AARON 2012 1728 fr 44 0.00440
## 10 M AARON 2013 1907 fr 41 0.00492
## # ℹ 41,990 more rows
#Pour les US :
name_us_300 <- name_us_48 |>
group_by(year,sex) |>
arrange(desc(n)) |>
mutate(rr=row_number(), p=n/sum(n)) |>
filter(rr<=300) |>
arrange(name,year,sex)
name_us_300
## # A tibble: 42,000 × 7
## # Groups: year, sex [140]
## year sex name n country rr p
## <dbl> <fct> <chr> <int> <chr> <int> <dbl>
## 1 2009 M Aaden 1267 us 271 0.000640
## 2 1994 F Aaliyah 1451 us 202 0.000813
## 3 1995 F Aaliyah 1255 us 225 0.000714
## 4 1997 F Aaliyah 1739 us 176 0.000999
## 5 1998 F Aaliyah 1399 us 222 0.000792
## 6 1999 F Aaliyah 1088 us 286 0.000614
## 7 2000 F Aaliyah 1496 us 211 0.000824
## 8 2001 F Aaliyah 3352 us 96 0.00186
## 9 2002 F Aaliyah 4778 us 64 0.00266
## 10 2003 F Aaliyah 3672 us 90 0.00201
## # ℹ 41,990 more rows
Ensuite, on va essayer de calculer les moyennes mobiles des popularités. On utilise la fonction rollmeanr du package zoo trouvée sur https://stackoverflow.com/questions/16193333/moving-average-of-previous-three-values-in-r.
name_fr_rm <- name_fr_300 |> group_by(name) |>
mutate(moy_mobile = rollmeanr(p,4, fill=NA))
name_fr_rm
## # A tibble: 42,000 × 8
## # Groups: name [1,857]
## sex name year n country rr p moy_mobile
## <fct> <chr> <int> <dbl> <chr> <int> <dbl> <dbl>
## 1 M AARON 2004 335 fr 206 0.000865 NA
## 2 M AARON 2005 439 fr 168 0.00113 NA
## 3 M AARON 2006 598 fr 120 0.00150 NA
## 4 M AARON 2007 910 fr 83 0.00231 0.00145
## 5 M AARON 2008 1380 fr 59 0.00346 0.00210
## 6 M AARON 2009 1355 fr 56 0.00343 0.00267
## 7 M AARON 2010 1606 fr 50 0.00403 0.00331
## 8 M AARON 2011 1765 fr 43 0.00450 0.00386
## 9 M AARON 2012 1728 fr 44 0.00440 0.00409
## 10 M AARON 2013 1907 fr 41 0.00492 0.00446
## # ℹ 41,990 more rows
name_us_rm <- name_us_300 |> group_by(name) |>
mutate(moy_mobile = rollmeanr(p,4, fill=NA))
name_us_rm
## # A tibble: 42,000 × 8
## # Groups: name [1,608]
## year sex name n country rr p moy_mobile
## <dbl> <fct> <chr> <int> <chr> <int> <dbl> <dbl>
## 1 2009 M Aaden 1267 us 271 0.000640 NA
## 2 1994 F Aaliyah 1451 us 202 0.000813 NA
## 3 1995 F Aaliyah 1255 us 225 0.000714 NA
## 4 1997 F Aaliyah 1739 us 176 0.000999 NA
## 5 1998 F Aaliyah 1399 us 222 0.000792 0.000829
## 6 1999 F Aaliyah 1088 us 286 0.000614 0.000780
## 7 2000 F Aaliyah 1496 us 211 0.000824 0.000807
## 8 2001 F Aaliyah 3352 us 96 0.00186 0.00102
## 9 2002 F Aaliyah 4778 us 64 0.00266 0.00149
## 10 2003 F Aaliyah 3672 us 90 0.00201 0.00184
## # ℹ 41,990 more rows
Nous allons étudier les variations. J’expliquerai par la suite mon code.
name_fr_rm$categorie <- NA #on crée la colonne de catégorie
tendance <- function(mobilemoy) {
if (all(diff(mobilemoy, na.rm = TRUE) < 0, na.rm = TRUE)) {
return('Baisse continue')
} else if (all(diff(mobilemoy, na.rm = TRUE) > 0, na.rm = TRUE)) {
return('Hausse continue')
} else if (!is.na(which.max(mobilemoy)) & !is.na(which.min(mobilemoy)) & which.max(mobilemoy) < which.min(mobilemoy)) {
return('Populaire suivi d\'un déclin')
} else if (!is.na(which.max(mobilemoy)) & !is.na(which.min(mobilemoy)) & which.max(mobilemoy) > which.min(mobilemoy)) {
return('Déclin suivi d\'un regain de popularité')
}
}
for (name in unique(name_fr_rm$name)) {
groupbyprenom <- name_fr_rm[name_fr_rm$name == name, ]
truc <- tendance(groupbyprenom$moy_mobile)
name_fr_rm[name_fr_rm$name == name, 'categorie'] <- truc
}
unique(name_fr_rm[, c('name', 'categorie')])
## # A tibble: 1,857 × 2
## # Groups: name [1,857]
## name categorie
## <chr> <chr>
## 1 AARON Hausse continue
## 2 ABDALLAH Hausse continue
## 3 ABDEL Déclin suivi d'un regain de popularité
## 4 ABDELAZIZ Baisse continue
## 5 ABDELKADER Déclin suivi d'un regain de popularité
## 6 ABDELKRIM Déclin suivi d'un regain de popularité
## 7 ABEL Déclin suivi d'un regain de popularité
## 8 ACHILLE Déclin suivi d'un regain de popularité
## 9 ADAM Hausse continue
## 10 ADEL Déclin suivi d'un regain de popularité
## # ℹ 1,847 more rows
Dans notre fonction “tendance” qui va catégoriser chaque prénom, nous utilisons la fonction diff() qui calcule la différence entre les valeurs de la moyenne mobile, en igorant les valeurs manquantes grâce à na.rm=TRUE (cf. https://thinkr.fr/abcdr/comment-gerer-les-donnees-manquantes-lors-dune-operation-grace-au-parametre-na-rm/). Je le met partout par tatonnement, pour que le code marche…
(all(diff(mobilemoy, na.rm = TRUE) < 0, na.rm = TRUE)) : on vérifie si toutes les différences des moyennes mobiles du prénom sont négatives. Si c’est le cas, alors c’est une baisse continue de popularité. Si ce n’est pas le cas, on passe à un autre “else if..” :
else if (all(diff(mobilemoy, na.rm = TRUE) > 0, na.rm = TRUE)) : c’est lan même chose mais pour la hausse. Si toutes les différences des moyennes mobiles du prénom donné sont positives, alors c’est une hausse continue de popularité.
Si ce n’est dans aucun de ces deux cas, on vérifie si c’est une hausse PUIS un déclin de popularité ou l’inverse grâce aux deux else if suivants :
<< Else if (!is.na(which.max(mobilemoy)) & !is.na(which.min(mobilemoy)) & which.max(mobilemoy) < which.min(mobilemoy)) { return(‘Populaire suivi d\’un déclin’) } else if (!is.na(which.max(mobilemoy)) & !is.na(which.min(mobilemoy)) & which.max(mobilemoy) > which.min(mobilemoy)) { return(‘Déclin suivi d\’un regain de popularité’) >>
Avec !is.na(which.max(mobilemoy)) & !is.na(which.min(mobilemoy)) on vérifie que les valeurs renvoyées par which.max et which.min ne sont pas des NA.
Ensuite, pour utiliser la fonction, j’utilise une boucle for qui va parcourir chaque prénom de la base de données ( for (name in unique(name_fr_rm$name)) ). Ici c’est comme un SELECT DISTINCT.
Ensuite je vais faire groupbyprenom <- name_fr_rm\[name_fr_rm\$name == name, \], ça va donc prendre en compte uniquement les lignes suivantes (donc les années suivantes) dont le prénom est identique à celui actuellement pris dans la boucle for du début. Ca nous fait comme une mini base de données d’un unique prénom pour toutes les années.
A celà on va appliquer notre fonction tendance expliquée plus haut, sur les p associés au prénom de la boucle for. Cela va nous renvoyer la catégorie. Nous l’avons appelé truc par manque d’inspiration et pour ne pas nous mélanger les pinceaux avec la colonne catégorie que nous avons créé.
A la fin, j’associe la catégorie du prénom (‘truc’) à la colonne catégorie de notre base de donnée pour chaque année ou le prénom est identique au prénom actuellement étudié de la boucle for. name_fr_rm\[name_fr_rm\$name == name, 'categorie'\] <- truc.
On peut faire la même chose pour les us :
name_us_rm$categorie <- NA
for (name in unique(name_us_rm$name)) {
groupbyprenom <- name_us_rm[name_us_rm$name == name, ]
truc <- tendance(groupbyprenom$moy_mobile)
name_us_rm[name_us_rm$name == name, 'categorie'] <- truc
}
unique(name_us_rm[, c('name', 'categorie')])
## # A tibble: 1,608 × 2
## # Groups: name [1,608]
## name categorie
## <chr> <chr>
## 1 Aaden Baisse continue
## 2 Aaliyah Déclin suivi d'un regain de popularité
## 3 Aaron Déclin suivi d'un regain de popularité
## 4 Abby Déclin suivi d'un regain de popularité
## 5 Abel Hausse continue
## 6 Abigail Déclin suivi d'un regain de popularité
## 7 Abraham Déclin suivi d'un regain de popularité
## 8 Ace Baisse continue
## 9 Adaline Baisse continue
## 10 Adalyn Hausse continue
## # ℹ 1,598 more rows
Nous avons utilisé des boucles if, elif et for comme dans python car nous manipulons ce language depuis la première année de licence et il était donc plus facile pour nous d’essayer comme cela. Nous pensons que ce code n’est pas optimisé et pas parfait car si on regarde par exemple le premier prénom de la table française (Aaron), on remarque que notre code renvoie “Hausse continue”. Or ce prénom n’est apparu dans les 300 prénoms les plus donnés qu’à partir de 2004. Il a connu une hausse continue que depuis 2004. Le code n’a pas pu prendre en compte que le prénom n’existait pas avant.